
Dim bk_rowPos As Integer

'get all sheets between sheet[Start] and sheet[End]
Sub getSheetsName(WkBk As String)

Dim i, start_index, end_index, NumRow, rowBkName As Integer
Dim BkPath As String
BkPath = Strings.Left(WkBk, Strings.InStrRev(WkBk, "\"))

NumRow = 1
start_index = 0
end_index = 0

Set wk_bk = Workbooks.Open(WkBk)

For i = 1 To wk_bk.Sheets.Count
    If wk_bk.Sheets(i).Name = "Start" Then
        start_index = i
    End If
    If wk_bk.Sheets(i).Name = "End" Then
        end_index = i
    End If
Next i

If end_index - start_index > 1 Then
    rowBkName = bk_rowPos
    For i = start_index + 1 To end_index - 1
        ThisWorkbook.ActiveSheet.Cells(bk_rowPos, 3) = wk_bk.Sheets(i).Name
        ThisWorkbook.ActiveSheet.Cells(bk_rowPos, 4) = "='" & BkPath & "[" & ThisWorkbook.ActiveSheet.Cells(rowBkName, 2).Value & "]" & _
                                                                                                    ThisWorkbook.ActiveSheet.Cells(bk_rowPos, 3).Value & "'!" & "B1"
        ThisWorkbook.ActiveSheet.Cells(bk_rowPos, 5) = "='" & BkPath & "[" & ThisWorkbook.ActiveSheet.Cells(rowBkName, 2).Value & "]" & _
                                                                                                    ThisWorkbook.ActiveSheet.Cells(bk_rowPos, 3).Value & "'!" & "B2"
        ThisWorkbook.ActiveSheet.Cells(bk_rowPos, 6) = "='" & BkPath & "[" & ThisWorkbook.ActiveSheet.Cells(rowBkName, 2).Value & "]" & _
                                                                                                    ThisWorkbook.ActiveSheet.Cells(bk_rowPos, 3).Value & "'!" & "B3"
        ThisWorkbook.ActiveSheet.Cells(bk_rowPos, 7) = "='" & BkPath & "[" & ThisWorkbook.ActiveSheet.Cells(rowBkName, 2).Value & "]" & _
                                                                                                    ThisWorkbook.ActiveSheet.Cells(bk_rowPos, 3).Value & "'!" & "B4"
        ThisWorkbook.ActiveSheet.Cells(bk_rowPos, 8) = "='" & BkPath & "[" & ThisWorkbook.ActiveSheet.Cells(rowBkName, 2).Value & "]" & _
                                                                                                    ThisWorkbook.ActiveSheet.Cells(bk_rowPos, 3).Value & "'!" & "B5"
        ThisWorkbook.ActiveSheet.Cells(bk_rowPos, 9) = "='" & BkPath & "[" & ThisWorkbook.ActiveSheet.Cells(rowBkName, 2).Value & "]" & _
                                                                                                    ThisWorkbook.ActiveSheet.Cells(bk_rowPos, 3).Value & "'!" & "B6"
        bk_rowPos = bk_rowPos + 1
    Next i
    
    bk_rowPos = bk_rowPos - 1

End If

wk_bk.Close

End Sub

Sub listAllExcelFile_Sheets()
Dim f As String
Dim file() As String
Dim x, i, k As Integer
i = 1
k = 1
x = 1
bk_rowPos = 3 '-- start row number

'-- clear content
ThisWorkbook.ActiveSheet.Range("A1:ZZ65535") = ""
 
 '-- WorkBook    Sheet   Total   Execute OK  NG  Todo    Suspend
 ThisWorkbook.ActiveSheet.Cells(2, 2) = "WorkBook"
 ThisWorkbook.ActiveSheet.Cells(2, 3) = "Sheet"
 ThisWorkbook.ActiveSheet.Cells(2, 4) = "Total"
 ThisWorkbook.ActiveSheet.Cells(2, 5) = "Execute"
 ThisWorkbook.ActiveSheet.Cells(2, 6) = "OK"
 ThisWorkbook.ActiveSheet.Cells(2, 7) = "NG"
 ThisWorkbook.ActiveSheet.Cells(2, 8) = "ToDo"
 ThisWorkbook.ActiveSheet.Cells(2, 9) = "Suspend"
 
ReDim file(1 To i)
file(1) = ThisWorkbook.Path & "\"
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")

'-- get current dir and all sub dirs recrusively.
Do Until i > k
    If Not FSO.FolderExists(file(i)) Then
        GoTo nextDo
    End If
    f = Dir(file(i), vbDirectory)
    Do
        If FSO.FolderExists(file(i) & f & "\") And (f <> ".") And (f <> "..") Then ' pass when file_without_extension
            k = k + 1
            ReDim Preserve file(1 To k)
            file(k) = file(i) & f & "\"
        End If
        f = Dir(, vbDirectory)
    Loop Until f = ""
nextDo:
    i = i + 1
Loop

'-- get all files of given extension in all given dirs.
For i = 1 To k
    f = Dir(file(i) & "*.xls*")     '-- wild card
    Do Until f = ""
         If f <> ThisWorkbook.Name Then '-- exclude current work book
            ThisWorkbook.ActiveSheet.Cells(bk_rowPos, 2) = f
            
            '-- add hyperlink to file.
            ThisWorkbook.ActiveSheet.Hyperlinks.Add _
            Anchor:=ThisWorkbook.ActiveSheet.Cells(bk_rowPos, 2), _
            Address:=file(i) & f
            
            getSheetsName (file(i) & f)
            bk_rowPos = bk_rowPos + 1
       End If
       f = Dir
    Loop
Next i

End Sub
